home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / lib / proc.tcl < prev    next >
Encoding:
Text File  |  1997-10-23  |  11.6 KB  |  365 lines
  1. ##############################################################################
  2. # $Id: proc.tcl,v 1.17 1997/10/24 01:47:41 stewart Exp $
  3. #
  4. # proc.tcl - procedures for manipulating proctions and the proction browser
  5. #
  6. # Copyright (C) 1996-1997 Stewart Allen
  7. #
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the terms of the GNU General Public License
  10. # as published by the Free Software Foundation; either version 2
  11. # of the License, or (at your option) any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful,
  14. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. # GNU General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program; if not, write to the Free Software
  20. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ##############################################################################
  23. #
  24.  
  25. proc vTcl:delete_proc {name} {
  26.     global vTcl
  27.     if {$name != ""} {
  28.         rename $name ""
  29.         vTcl:list delete "{$name}" vTcl(procs)
  30.         vTcl:update_proc_list
  31.     }
  32. }
  33.  
  34. proc vTcl:find_new_procs {} {
  35.     global vTcl
  36.     return [vTcl:diff_list $vTcl(start,procs) [info procs]]
  37. }
  38.  
  39. proc vTcl:proc:get_args { name } {
  40.     set args {}
  41.     if {$name != ""} {
  42.         foreach j [info args $name] {
  43.             if {[info default $name $j def]} {
  44.                 lappend args [list $j $def]
  45.             } else {
  46.                 lappend args $j
  47.             }
  48.         }
  49.     }
  50.     return $args
  51. }
  52.  
  53. proc vTcl:show_proc {name} {
  54.     global vTcl
  55.     if {$name != ""} {
  56.         set args [vTcl:proc:get_args $name]
  57.         set body [string trim [info body $name] "\n"]
  58.         set win .vTcl.proc_[vTcl:rename $name]
  59.         Window show .vTcl.proc $win $name $args $body
  60.     } else {
  61.         Window show .vTcl.proc .vTcl.proc_new "" "" ""
  62.     }
  63. }
  64.  
  65. proc vTcl:proclist:show {{on ""}} {
  66.     global vTcl
  67.     if {$on == "flip"} { set on [expr - $vTcl(pr,show_func)] }
  68.     if {$on == ""}     { set on $vTcl(pr,show_func) }
  69.     if {$on == 1} {
  70.         Window show $vTcl(gui,proclist)
  71.         vTcl:update_proc_list
  72.     } else {
  73.         Window hide $vTcl(gui,proclist)
  74.     }
  75.     set vTcl(pr,show_func) $on
  76. }
  77.  
  78. proc vTcl:update_proc {base} {
  79.     global vTcl
  80.     set vTcl(pr,geom_proc) [lindex [split [wm geom $base] +-] 0]
  81.     set name [$base.f2.f8.procname get]
  82.     set args [$base.f2.f9.args get]
  83.     set body [string trim [$base.f3.text get 0.0 end] "\n"]
  84.     if {$name != ""} {
  85.         proc $name $args $body
  86.     }
  87.     vTcl:list add "{$name}" vTcl(procs)
  88.     grab release $base
  89.     destroy $base
  90.     vTcl:update_proc_list $name
  91. }
  92.  
  93. proc vTcl:update_proc_list {{name {}}} {
  94.     global vTcl
  95.     if { [winfo exists $vTcl(gui,proclist)] == 0 } { return }
  96.     $vTcl(gui,proclist).f2.list delete 0 end
  97.     foreach i [lsort $vTcl(procs)] {
  98.         if {[vTcl:valid_procname $i] == 1} {
  99.             if {[info body $i] != "" || $i == "main" || $i == "init"} {
  100.                 $vTcl(gui,proclist).f2.list insert end $i
  101.             }
  102.         }
  103.     }
  104.     if {$name != ""} {
  105.         set plist [$vTcl(gui,proclist).f2.list get 0 end]
  106.         set pindx [lsearch $plist $name]
  107.         if {$pindx >= 0} {
  108.         $vTcl(gui,proclist).f2.list selection set $pindx
  109.         }
  110.     }
  111. }
  112.  
  113. # kc: during File->Open or File->Source, determine if we should keep
  114. # record of proc $name.  Used to exclude tix procs that get defined as a
  115. # byproduct of creating tix widgets.
  116. #
  117. # returns:
  118. #   1 if should be ignored, 0 if should be kept
  119. #
  120. proc vTcl:ignore_procname_when_sourcing {name} {
  121.     global vTcl
  122.     if [regexp "^($vTcl(proc,ignore))" $name] {
  123.         return 1
  124.     } else {
  125.         return 0
  126.     }
  127. }
  128.  
  129. # kc: during File->Save, determine if proc $name should be saved.  Used
  130. # to prevent global tk and tix functions from being saved.
  131. #
  132. # returns:
  133. #   1 if should be ignored, 0 if saved
  134. #
  135. proc vTcl:ignore_procname_when_saving {name} {
  136.     global vTcl
  137.     set len [expr [string length $vTcl(winname)] - 1]
  138.     if {[regexp "^($vTcl(proc,ignore))" $name] \
  139.             || ([string range $name 0 $len] == "$vTcl(winname)")} {
  140.         return 1
  141.     } else {
  142.         return 0
  143.     }
  144. }
  145.  
  146. # kc: for backward compatibility
  147. proc vTcl:valid_procname {name} {
  148.     return [expr ![vTcl:ignore_procname_when_saving $name]]
  149. }
  150.  
  151. proc vTclWindow.vTcl.proclist {args} {
  152.     global vTcl
  153.     set base .vTcl.proclist
  154.     if { [winfo exists $base] } { wm deiconify $base; return }
  155.     toplevel $base -class vTcl
  156.     wm transient $base .vTcl
  157.     wm focusmodel $base passive
  158.     wm geometry $base 200x200+48+237
  159.     wm maxsize $base 1137 870
  160.     wm minsize $base 200 100
  161.     wm overrideredirect $base 0
  162.     wm resizable $base 1 1
  163.     wm deiconify $base
  164.     wm title $base "Function List"
  165.     wm protocol $base WM_DELETE_WINDOW {vTcl:proclist:show 0}
  166.     frame $base.frame7 \
  167.         -borderwidth 1 -height 30 -relief sunken -width 30 
  168.     pack $base.frame7 \
  169.         -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  170.         -side bottom 
  171.     button $base.frame7.button8 \
  172.         -command {vTcl:show_proc ""} \
  173.          -padx 9 \
  174.         -pady 3 -text Add -width 4 
  175.     pack $base.frame7.button8 \
  176.         -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  177.         -side left 
  178.     button $base.frame7.button9 \
  179.         -command {
  180.             set vTcl(x) [.vTcl.proclist.f2.list curselection]
  181.             if {$vTcl(x) != ""} {
  182.                 vTcl:show_proc [.vTcl.proclist.f2.list get $vTcl(x)]
  183.             }
  184.         } \
  185.         -padx 9 \
  186.         -pady 3 -text Edit -width 4 
  187.     pack $base.frame7.button9 \
  188.         -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  189.         -side left 
  190.     button $base.frame7.button10 \
  191.         -command {
  192.             set vTcl(x) [.vTcl.proclist.f2.list curselection]
  193.             if {$vTcl(x) != ""} {
  194.                 vTcl:delete_proc [.vTcl.proclist.f2.list get $vTcl(x)]
  195.             }
  196.         } \
  197.         -padx 9 \
  198.         -pady 3 -text Delete -width 4 
  199.     pack $base.frame7.button10 \
  200.         -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  201.         -side left 
  202.     button $base.frame7.button11 \
  203.         -command { vTcl:proclist:show 0 }\
  204.          -padx 9 -pady 3 -text Done -width 4 
  205.     pack $base.frame7.button11 \
  206.         -anchor center -expand 1 -fill x -side left
  207.     frame $base.f2 \
  208.         -borderwidth 1 -height 30 -relief sunken -width 30 
  209.     pack $base.f2 \
  210.         -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  211.         -side top 
  212.     listbox $base.f2.list \
  213.         -yscrollcommand {.vTcl.proclist.f2.sb4  set} 
  214.     bind $base.f2.list <Double-Button-1> {
  215.         set vTcl(x) [.vTcl.proclist.f2.list curselection]
  216.         if {$vTcl(x) != ""} {
  217.             vTcl:show_proc [.vTcl.proclist.f2.list get $vTcl(x)]
  218.         }
  219.     }
  220.     pack $base.f2.list \
  221.         -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  222.         -side left 
  223.     scrollbar $base.f2.sb4 \
  224.         -borderwidth 1 -command "$base.f2.list yview"
  225.     pack $base.f2.sb4 \
  226.         -anchor center -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  227.         -side right 
  228.  
  229.     wm withdraw $vTcl(gui,proclist)
  230.     vTcl:setup_vTcl:bind $vTcl(gui,proclist)
  231.     catch {wm geometry $vTcl(gui,proclist) $vTcl(geometry,$vTcl(gui,proclist))}
  232.     update idletasks
  233.     wm deiconify $vTcl(gui,proclist)
  234. }
  235.  
  236. proc vTclWindow.vTcl.proc {args} {
  237.     global vTcl
  238.     set base "[lindex $args 0]"
  239.     set title "[lindex $args 1]"
  240.     set iproc [lindex $args 1]
  241.     set iargs [lindex $args 2]
  242.     set ibody [lindex $args 3]
  243.     if { [winfo exists $base] } { wm deiconify $base; return }
  244.     set vTcl(proc,[lindex $args 0],chg) 0
  245.     toplevel $base -class vTcl
  246.     wm transient $base .vTcl
  247.     wm focusmodel $base passive
  248.     wm geometry $base $vTcl(pr,geom_proc)
  249.     wm maxsize $base 1137 870
  250.     wm minsize $base 1 1
  251.     wm overrideredirect $base 0
  252.     wm resizable $base 1 1
  253.     wm deiconify $base
  254.     wm title $base "$title"
  255.     bind $base <Key-Escape> "vTcl:update_proc $base"
  256.     frame $base.f2 -height 30 -width 30 
  257.     pack $base.f2 \
  258.         -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 3 -pady 3 \
  259.         -side top 
  260.     frame $base.f2.f8 -height 30 -width 30 
  261.     pack $base.f2.f8 \
  262.         -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  263.         -side top 
  264.     label $base.f2.f8.label10 -anchor w  \
  265.         -relief groove -text Function -width 9 
  266.     pack $base.f2.f8.label10 \
  267.         -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 2 -pady 0 \
  268.         -side left 
  269.     entry $base.f2.f8.procname \
  270.         -cursor {}  \
  271.         -highlightthickness 0 
  272.     pack $base.f2.f8.procname \
  273.         -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 2 -pady 2 \
  274.         -side left 
  275.     frame $base.f2.f9 \
  276.         -height 30 -width 30 
  277.     pack $base.f2.f9 \
  278.         -anchor center -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  279.         -side top 
  280.     label $base.f2.f9.label12 \
  281.         -anchor w  \
  282.         -relief groove -text Arguments -width 9 
  283.     pack $base.f2.f9.label12 \
  284.         -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 2 -pady 0 \
  285.         -side left 
  286.     entry $base.f2.f9.args \
  287.         -cursor {}  \
  288.         -highlightthickness 0 
  289.     pack $base.f2.f9.args \
  290.         -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 2 -pady 2 \
  291.         -side left 
  292.     frame $base.f3 \
  293.         -borderwidth 2 -height 30 -relief groove -width 30 
  294.     pack $base.f3 \
  295.         -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 3 -pady 3 \
  296.         -side top 
  297.     text $base.f3.text \
  298.         -height 7 -highlightthickness 0 -width 16 \
  299.         -wrap none -yscrollcommand "$base.f3.scrollbar4 set"
  300.     pack $base.f3.text \
  301.         -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 2 -pady 2 \
  302.         -side left 
  303.     bind $base.f3.text <KeyPress> "+set vTcl(proc,[lindex $args 0],chg) 1"
  304.     scrollbar $base.f3.scrollbar4 \
  305.         -command "$base.f3.text yview"
  306.     pack $base.f3.scrollbar4 \
  307.         -anchor center -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  308.         -side left 
  309.     frame $base.frame14 \
  310.         -borderwidth 1 -height 30 -relief sunken -width 30 
  311.     pack $base.frame14 \
  312.         -anchor center -expand 0 -fill x -ipadx 0 -ipady 0 -padx 3 -pady 3 \
  313.         -side top 
  314.     button $base.frame14.button15 \
  315.         -command "vTcl:update_proc $base" \
  316.         -padx 9 -pady 3 -text OK -width 5 
  317.     pack $base.frame14.button15 \
  318.         -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  319.         -side left 
  320.     button $base.frame14.button16 \
  321.         -command "vTcl:proc:edit_cancel $base" \
  322.          -padx 9 \
  323.         -pady 3 -text Cancel -width 5 
  324.     pack $base.frame14.button16 \
  325.         -anchor center -expand 1 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 \
  326.         -side left 
  327.  
  328.     set pname $base.f2.f8.procname
  329.     set pargs $base.f2.f9.args
  330.     set pbody $base.f3.text
  331.     $pname delete 0 end
  332.     $pargs delete 0 end
  333.     $pbody delete 0.0 end
  334.     $pname insert end $iproc
  335.     $pargs insert end $iargs
  336.     $pbody insert end $ibody
  337.     $pbody mark set insert 0.0
  338.     if {$iproc == ""} {
  339.         focus $pname
  340.     } else {
  341.         focus $pbody
  342.     }
  343. }
  344.  
  345. proc vTcl:proc:edit_cancel {base} {
  346.     global vTcl
  347.     if {$vTcl(proc,$base,chg) == 0} {
  348.         grab release $base
  349.         destroy $base
  350.     } else {
  351.         vTcl:dialog "Buffer has changed. Do you\nwish to save the changes?" {Yes No Cancel}
  352.         switch $vTcl(x_mesg) {
  353.             No {
  354.                 grab release $base
  355.                 destroy $base
  356.             }
  357.             Yes {
  358.                 vTcl:update_proc $base
  359.             }
  360.             Cancel {}
  361.         }
  362.     }
  363. }
  364.  
  365.